home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / variable.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-16  |  5.9 KB  |  266 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47. #ifdef __STDC__
  48. static sizet
  49. free_var (SCM obj)
  50. #else
  51. static sizet
  52. free_var (obj)
  53.      SCM obj;
  54. #endif
  55. {
  56.   return 0;
  57. }
  58.  
  59.  
  60. #ifdef __STDC__
  61. static int
  62. prin_var (SCM exp, SCM port, int writing)
  63. #else
  64. static int
  65. prin_var (exp, port, writing)
  66.      SCM exp;
  67.      SCM port;
  68.      int writing;
  69. #endif
  70. {
  71.   scm_puts("#<variable ", port);
  72.   scm_intprint(exp, 16, port);
  73.   {
  74.     SCM val_cell;
  75.     val_cell = CDR(exp);
  76.     if (CAR (val_cell) != SCM_UNDEFINED)
  77.       {
  78.     scm_puts(" name: ", port);
  79.     scm_iprin1 (CAR (val_cell), port, writing);
  80.       }
  81.     scm_puts(" binding: ", port);
  82.     scm_iprin1 (CDR (val_cell), port, writing);
  83.   }
  84.   scm_putc('>', port);
  85.   return 1;
  86. }
  87. int scm_tc16_variable;
  88. static scm_smobfuns variable_smob = {scm_markcdr, free_var, prin_var, 0};
  89.  
  90.  
  91. static SCM variable_sym;
  92.  
  93. static char s_make_variable[];
  94. #ifdef __STDC__
  95. static SCM
  96. make_vcell_variable (SCM vcell)
  97. #else
  98. static SCM
  99. make_vcell_variable (vcell)
  100.      SCM vcell;
  101. #endif
  102. {
  103.   SCM answer;
  104.   NEWCELL(answer);
  105.   DEFER_INTS;
  106.   CAR(answer) = scm_tc16_variable;
  107.   CDR(answer) = vcell;
  108.   ALLOW_INTS;
  109.   return answer;
  110. }
  111.  
  112. PROC (s_make_variable, "make-variable", 2, 0, 0, scm_make_variable);
  113. #ifdef __STDC__
  114. SCM
  115. scm_make_variable (SCM init, SCM name_hint)
  116. #else
  117. SCM
  118. scm_make_variable (init, name_hint)
  119.      SCM init;
  120.      SCM name_hint;
  121. #endif
  122. {
  123.   SCM val_cell;
  124.   NEWCELL(val_cell);
  125.   DEFER_INTS;
  126.   CAR(val_cell) = name_hint;
  127.   CDR(val_cell) = init;
  128.   ALLOW_INTS;
  129.   return make_vcell_variable (val_cell);
  130. }
  131.  
  132.  
  133. PROC (s_make_undefined_variable, "make-undefined-variable", 0, 0, 1, scm_make_undefined_variable);
  134. #ifdef __STDC__
  135. SCM
  136. scm_make_undefined_variable (SCM name_hint)
  137. #else
  138. SCM
  139. scm_make_undefined_variable (name_hint)
  140.      SCM name_hint;
  141. #endif
  142. {
  143.   SCM vcell;
  144.  
  145.   if (name_hint == SCM_UNDEFINED)
  146.     name_hint = variable_sym;
  147.  
  148.   NEWCELL (vcell);
  149.   DEFER_INTS;
  150.   CAR (vcell) = name_hint;
  151.   CDR (vcell) = SCM_UNDEFINED;
  152.   ALLOW_INTS;
  153.   return make_vcell_variable (vcell);
  154. }
  155.  
  156.  
  157. PROC (s_variable_p, "variable?", 1, 0, 0, scm_variable_p);
  158. #ifdef __STDC__
  159. SCM
  160. scm_variable_p (SCM obj)
  161. #else
  162. SCM
  163. scm_variable_p (obj)
  164.      SCM obj;
  165. #endif
  166. {
  167.   return ( (NIMP(obj) && VARIABLEP (obj))
  168.       ? BOOL_T
  169.       : BOOL_F);
  170. }
  171.  
  172.  
  173. PROC (s_variable_ref, "variable-ref", 1, 0, 0, scm_variable_ref);
  174. #ifdef __STDC__
  175. SCM
  176. scm_variable_ref (SCM var)
  177. #else
  178. SCM
  179. scm_variable_ref (var)
  180.      SCM var;
  181. #endif
  182. {
  183.   ASSERT (NIMP(var) && VARIABLEP(var), var, ARG1, s_variable_ref);
  184.   return CDR (CDR (var));
  185. }
  186.  
  187.  
  188.  
  189. PROC (s_variable_set_x, "variable-set!", 2, 0, 0, scm_variable_set_x);
  190. #ifdef __STDC__
  191. SCM
  192. scm_variable_set_x (SCM var, SCM val)
  193. #else
  194. SCM
  195. scm_variable_set_x (var, val)
  196.      SCM var;
  197.      SCM val;
  198. #endif
  199. {
  200.   ASSERT (NIMP(var) && VARIABLEP (var), var, ARG1, s_variable_set_x);
  201.   CDR (CDR (var)) = val;
  202.   return UNSPECIFIED;
  203. }
  204.  
  205.  
  206. PROC (s_builtin_variable, "builtin-variable", 1, 0, 0, scm_builtin_variable);
  207. #ifdef __STDC__
  208. SCM
  209. scm_builtin_variable (SCM name)
  210. #else
  211. SCM
  212. scm_builtin_variable (name)
  213.      SCM name;
  214. #endif
  215. {
  216.   SCM vcell;
  217.   SCM var_slot;
  218.  
  219.   ASSERT (NIMP (name) && SYMBOLP (name), name, ARG1, s_builtin_variable);
  220.   vcell = scm_sym2vcell (name, BOOL_F, BOOL_F);
  221.   if (vcell == BOOL_F)
  222.     return BOOL_F;
  223.  
  224.   scm_intern_symbol (symhash_vars, name);
  225.   var_slot = scm_sym2ovcell (name, symhash_vars);
  226.  
  227.   if (   IMP (CDR (var_slot))
  228.       || (VARVCELL (var_slot) != vcell))
  229.     CDR (var_slot) = make_vcell_variable (vcell);
  230.  
  231.   return CDR (var_slot);
  232. }
  233.  
  234.  
  235. PROC (s_variable_bound_p, "variable-bound?", 1, 0, 0, scm_variable_bound_p);
  236. #ifdef __STDC__
  237. SCM 
  238. scm_variable_bound_p (SCM var)
  239. #else
  240. SCM 
  241. scm_variable_bound_p (var)
  242.      SCM var;
  243. #endif
  244. {
  245.   ASSERT (NIMP(var) && VARIABLEP (var), var, ARG1, s_variable_bound_p);
  246.   return (UNBNDP (CDR (VARVCELL (var)))
  247.       ? BOOL_F
  248.       : BOOL_T);
  249. }
  250.  
  251.  
  252.  
  253. #ifdef __STDC__
  254. void
  255. scm_init_variable (void)
  256. #else
  257. void
  258. scm_init_variable ()
  259. #endif
  260. {
  261.   scm_tc16_variable = scm_newsmob (&variable_smob);
  262.   variable_sym = CAR (scm_sysintern ("anonymous-variable", SCM_UNDEFINED));
  263. #include "variable.x"
  264. }
  265.  
  266.